home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Net / Domain.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  7.2 KB  |  348 lines
  1. # Net::Domain.pm
  2. #
  3. # Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package Net::Domain;
  8.  
  9. require Exporter;
  10.  
  11. use Carp;
  12. use strict;
  13. use vars qw($VERSION @ISA @EXPORT_OK);
  14. use Net::Config;
  15.  
  16. @ISA       = qw(Exporter);
  17. @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
  18.  
  19. $VERSION = "2.20";
  20.  
  21. my ($host, $domain, $fqdn) = (undef, undef, undef);
  22.  
  23. # Try every conceivable way to get hostname.
  24.  
  25.  
  26. sub _hostname {
  27.  
  28.   # we already know it
  29.   return $host
  30.     if (defined $host);
  31.  
  32.   if ($^O eq 'MSWin32') {
  33.     require Socket;
  34.     my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
  35.     while (@addr) {
  36.       my $a = shift(@addr);
  37.       $host = gethostbyaddr($a, Socket::AF_INET());
  38.       last if defined $host;
  39.     }
  40.     if (defined($host) && index($host, '.') > 0) {
  41.       $fqdn = $host;
  42.       ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
  43.     }
  44.     return $host;
  45.   }
  46.   elsif ($^O eq 'MacOS') {
  47.     chomp($host = `hostname`);
  48.   }
  49.   elsif ($^O eq 'VMS') {    ## multiple varieties of net s/w makes this hard
  50.     $host = $ENV{'UCX$INET_HOST'}      if defined($ENV{'UCX$INET_HOST'});
  51.     $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
  52.     if (index($host, '.') > 0) {
  53.       $fqdn = $host;
  54.       ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
  55.     }
  56.     return $host;
  57.   }
  58.   else {
  59.     local $SIG{'__DIE__'};
  60.  
  61.     # syscall is preferred since it avoids tainting problems
  62.     eval {
  63.       my $tmp = "\0" x 256;    ## preload scalar
  64.       eval {
  65.         package main;
  66.         require "syscall.ph";
  67.         defined(&main::SYS_gethostname);
  68.         }
  69.         || eval {
  70.         package main;
  71.         require "sys/syscall.ph";
  72.         defined(&main::SYS_gethostname);
  73.         }
  74.         and $host =
  75.         (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
  76.         ? $tmp
  77.         : undef;
  78.       }
  79.  
  80.       # POSIX
  81.       || eval {
  82.       require POSIX;
  83.       $host = (POSIX::uname())[1];
  84.       }
  85.  
  86.       # trusty old hostname command
  87.       || eval {
  88.       chop($host = `(hostname) 2>/dev/null`);    # BSD'ish
  89.       }
  90.  
  91.       # sysV/POSIX uname command (may truncate)
  92.       || eval {
  93.       chop($host = `uname -n 2>/dev/null`);      ## SYSV'ish && POSIX'ish
  94.       }
  95.  
  96.       # Apollo pre-SR10
  97.       || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
  98.  
  99.       || eval { $host = ""; };
  100.   }
  101.  
  102.   # remove garbage
  103.   $host =~ s/[\0\r\n]+//go;
  104.   $host =~ s/(\A\.+|\.+\Z)//go;
  105.   $host =~ s/\.\.+/\./go;
  106.  
  107.   $host;
  108. }
  109.  
  110.  
  111. sub _hostdomain {
  112.  
  113.   # we already know it
  114.   return $domain
  115.     if (defined $domain);
  116.  
  117.   local $SIG{'__DIE__'};
  118.  
  119.   return $domain = $NetConfig{'inet_domain'}
  120.     if defined $NetConfig{'inet_domain'};
  121.  
  122.   # try looking in /etc/resolv.conf
  123.   # putting this here and assuming that it is correct, eliminates
  124.   # calls to gethostbyname, and therefore DNS lookups. This helps
  125.   # those on dialup systems.
  126.  
  127.   local *RES;
  128.   local ($_);
  129.  
  130.   if (open(RES, "/etc/resolv.conf")) {
  131.     while (<RES>) {
  132.       $domain = $1
  133.         if (/\A\s*(?:domain|search)\s+(\S+)/);
  134.     }
  135.     close(RES);
  136.  
  137.     return $domain
  138.       if (defined $domain);
  139.   }
  140.  
  141.   # just try hostname and system calls
  142.  
  143.   my $host = _hostname();
  144.   my (@hosts);
  145.  
  146.   @hosts = ($host, "localhost");
  147.  
  148.   unless (defined($host) && $host =~ /\./) {
  149.     my $dom = undef;
  150.     eval {
  151.       my $tmp = "\0" x 256;    ## preload scalar
  152.       eval {
  153.         package main;
  154.         require "syscall.ph";
  155.         }
  156.         || eval {
  157.         package main;
  158.         require "sys/syscall.ph";
  159.         }
  160.         and $dom =
  161.         (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
  162.         ? $tmp
  163.         : undef;
  164.     };
  165.  
  166.     if ($^O eq 'VMS') {
  167.       $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
  168.         || $ENV{'UCX$INET_DOMAIN'};
  169.     }
  170.  
  171.     chop($dom = `domainname 2>/dev/null`)
  172.       unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
  173.  
  174.     if (defined $dom) {
  175.       my @h = ();
  176.       $dom =~ s/^\.+//;
  177.       while (length($dom)) {
  178.         push(@h, "$host.$dom");
  179.         $dom =~ s/^[^.]+.+// or last;
  180.       }
  181.       unshift(@hosts, @h);
  182.     }
  183.   }
  184.  
  185.   # Attempt to locate FQDN
  186.  
  187.   foreach (grep { defined $_ } @hosts) {
  188.     my @info = gethostbyname($_);
  189.  
  190.     next unless @info;
  191.  
  192.     # look at real name & aliases
  193.     my $site;
  194.     foreach $site ($info[0], split(/ /, $info[1])) {
  195.       if (rindex($site, ".") > 0) {
  196.  
  197.         # Extract domain from FQDN
  198.  
  199.         ($domain = $site) =~ s/\A[^\.]+\.//;
  200.         return $domain;
  201.       }
  202.     }
  203.   }
  204.  
  205.   # Look for environment variable
  206.  
  207.   $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
  208.  
  209.   if (defined $domain) {
  210.     $domain =~ s/[\r\n\0]+//g;
  211.     $domain =~ s/(\A\.+|\.+\Z)//g;
  212.     $domain =~ s/\.\.+/\./g;
  213.   }
  214.  
  215.   $domain;
  216. }
  217.  
  218.  
  219. sub domainname {
  220.  
  221.   return $fqdn
  222.     if (defined $fqdn);
  223.  
  224.   _hostname();
  225.   _hostdomain();
  226.  
  227.   # Assumption: If the host name does not contain a period
  228.   # and the domain name does, then assume that they are correct
  229.   # this helps to eliminate calls to gethostbyname, and therefore
  230.   # eleminate DNS lookups
  231.  
  232.   return $fqdn = $host . "." . $domain
  233.     if (defined $host
  234.     and defined $domain
  235.     and $host !~ /\./
  236.     and $domain =~ /\./);
  237.  
  238.   # For hosts that have no name, just an IP address
  239.   return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
  240.  
  241.   my @host   = defined $host   ? split(/\./, $host)   : ('localhost');
  242.   my @domain = defined $domain ? split(/\./, $domain) : ();
  243.   my @fqdn   = ();
  244.  
  245.   # Determine from @host & @domain the FQDN
  246.  
  247.   my @d = @domain;
  248.  
  249. LOOP:
  250.   while (1) {
  251.     my @h = @host;
  252.     while (@h) {
  253.       my $tmp = join(".", @h, @d);
  254.       if ((gethostbyname($tmp))[0]) {
  255.         @fqdn = (@h, @d);
  256.         $fqdn = $tmp;
  257.         last LOOP;
  258.       }
  259.       pop @h;
  260.     }
  261.     last unless shift @d;
  262.   }
  263.  
  264.   if (@fqdn) {
  265.     $host = shift @fqdn;
  266.     until ((gethostbyname($host))[0]) {
  267.       $host .= "." . shift @fqdn;
  268.     }
  269.     $domain = join(".", @fqdn);
  270.   }
  271.   else {
  272.     undef $host;
  273.     undef $domain;
  274.     undef $fqdn;
  275.   }
  276.  
  277.   $fqdn;
  278. }
  279.  
  280.  
  281. sub hostfqdn { domainname() }
  282.  
  283.  
  284. sub hostname {
  285.   domainname()
  286.     unless (defined $host);
  287.   return $host;
  288. }
  289.  
  290.  
  291. sub hostdomain {
  292.   domainname()
  293.     unless (defined $domain);
  294.   return $domain;
  295. }
  296.  
  297. 1;    # Keep require happy
  298.  
  299. __END__
  300.  
  301. =head1 NAME
  302.  
  303. Net::Domain - Attempt to evaluate the current host's internet name and domain
  304.  
  305. =head1 SYNOPSIS
  306.  
  307.     use Net::Domain qw(hostname hostfqdn hostdomain domainname);
  308.  
  309. =head1 DESCRIPTION
  310.  
  311. Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
  312. of the current host. From this determine the host-name and the host-domain.
  313.  
  314. Each of the functions will return I<undef> if the FQDN cannot be determined.
  315.  
  316. =over 4
  317.  
  318. =item hostfqdn ()
  319.  
  320. Identify and return the FQDN of the current host.
  321.  
  322. =item domainname ()
  323.  
  324. An alias for hostfqdn ().
  325.  
  326. =item hostname ()
  327.  
  328. Returns the smallest part of the FQDN which can be used to identify the host.
  329.  
  330. =item hostdomain ()
  331.  
  332. Returns the remainder of the FQDN after the I<hostname> has been removed.
  333.  
  334. =back
  335.  
  336. =head1 AUTHOR
  337.  
  338. Graham Barr <gbarr@pobox.com>.
  339. Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
  340.  
  341. =head1 COPYRIGHT
  342.  
  343. Copyright (c) 1995-1998 Graham Barr. All rights reserved.
  344. This program is free software; you can redistribute it and/or modify
  345. it under the same terms as Perl itself.
  346.  
  347. =cut
  348.